home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / powertb.arc / DATETIME.INC next >
Encoding:
Text File  |  1985-02-24  |  2.6 KB  |  105 lines
  1. { Turbo Pascal routines to read the date and time
  2.   Copywrite 1984 Michael A. Covington  }
  3.  
  4. { Each routine requires the following type definitions
  5.   but does not require the other routines }
  6.  
  7. type DateTimeType = string[8];
  8.      regtype      = record
  9.                     ax,bx,cx,dx,bp,si,di,ds,es,flags: integer
  10.                     end;
  11.  
  12. {==========================}
  13. function date: DateTimeType;
  14. {==========================}
  15.  
  16. { return current date in form MM/DD/YY }
  17.  
  18. var reg      : regtype;
  19.     y,m,d,w  : DateTimeType;
  20.     i        : integer;
  21.  
  22. begin
  23.    reg.ax := $2A00;
  24.    intr($21,reg);
  25.    str(reg.cx:4,y);
  26.    delete(y,1,2);
  27.    str(hi(reg.dx):2,m);
  28.    str(lo(reg.dx):2,d);
  29.    w := m + '/' + d +'/' + y;
  30.    for i := 1 to length(w) do if w[i] = ' ' then w[i] := '0';
  31.    date := w
  32. end;
  33.  
  34. {==========================}
  35. function time: DateTimeType;
  36. {==========================}
  37.  
  38. { return current date in form HH:MM:SS }
  39.  
  40. var reg      : regtype;
  41.     h,m,s,w  : DateTimeType;
  42.     i        : integer;
  43.  
  44. begin
  45.    reg.ax := $2C00;
  46.    intr($21,reg);
  47.    str(hi(reg.cx):2,h);
  48.    str(lo(reg.cx):2,m);
  49.    str(hi(reg.dx):2,s);
  50.    w := h + ':' + m +':' + s;
  51.    for i := 1 to length(w) do if w[i] = ' ' then w[i] := '0';
  52.    time := w
  53. end;
  54.  
  55. {================================}
  56. procedure setdate(x:DateTimeType);
  57. {================================}
  58.  
  59. { Sets date: Accepts string in format: MM/DD/YY }
  60.  
  61. var reg                : regtype;
  62.     rh, rl, c1, c2, c3 : integer;
  63.  
  64. begin
  65.    reg.ax := $2B00;
  66.    val(x[1]+x[2],rh,c1);  { Month goes in DH }
  67.    val(x[4]+x[5],rl,c2);  { Day goes in DL }
  68.    reg.dx := rh*256 + rl;
  69.    val(x[7]+x[8],rl,c3);  { Year goes in CX }
  70.    reg.cx := rl + 1900;
  71.    if rl<80 then reg.cx := reg.cx + 100; {21st century }
  72.    c1 := c1+c2+c3;       { return codes from Val }
  73.    if c1 = 0 then intr($21,reg);
  74.    if c1 + lo(reg.ax) <> 0 then begin
  75.       writeln;
  76.       writeln('Error -- invalid date: ''',x,'''');
  77.       halt
  78.       end
  79. end;
  80.  
  81. {================================}
  82. procedure settime(x:DateTimeType);
  83. {================================}
  84.  
  85. { Sets time: Accepts string in format: HH:MM:SS }
  86.  
  87. var reg                : regtype;
  88.     rh, rl, c1, c2, c3 : integer;
  89.  
  90. begin
  91.    reg.ax := $2D00;
  92.    val(x[1]+x[2],rh,c1);  { Hours go in CH }
  93.    val(x[4]+x[5],rl,c2);  { Minutes go in CL }
  94.    reg.cx := rh*256 + rl;
  95.    val(x[7]+x[8],rl,c3);  { Seconds go in DH }
  96.    reg.dx := rh*256;
  97.    c1 := c1+c2+c3;       { return codes from Val }
  98.    if c1 = 0 then intr($21,reg);
  99.    if c1 + lo(reg.ax) <> 0 then begin
  100.       writeln;
  101.       writeln('Error -- invalid time: ''',x,'''');
  102.       halt
  103.       end
  104. end;
  105.